home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / numtow_1 / numtotex.cls < prev    next >
Text File  |  1998-08-12  |  5KB  |  170 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "NumtoText"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Dim sErrString$
  13. Dim Count As Boolean
  14.  
  15. Public Function fChange$(ByVal sNumber$, Optional ByVal bUseForChecks As Boolean, Optional ByVal sCurrency As String)
  16. Dim nLength%: Dim nCounter%: Dim nCounter2%
  17. Dim nDecPlace%
  18. Dim sChar$: Dim sStrNum$
  19. Dim dNum#: Dim dFixedNum#
  20. Dim Remainder&
  21. Dim GetRem: Dim NrOver3
  22. Dim WrdCol As New Collection
  23.  
  24. On Error GoTo DoError
  25. If sNumber = "" Then Exit Function
  26. 'initialize placeholder variable
  27. nDecPlace = 0
  28. 'convert amount to number without any cents
  29. dNum = Fix(sNumber)
  30. 'get length of number
  31. 'have to use str because anyother data type returns nr of bytes, not length
  32. nLength = Len(Str(dNum)) - 1
  33.  
  34. 'get how many cents there are
  35. GetRem = CDbl(sNumber)
  36. Remainder = (GetRem - Fix(GetRem)) * 100
  37. 'place leading zeros in front of amount if neccessary
  38. 'so that amount is is in multiple of three.
  39. NrOver3 = nLength Mod 3
  40. dNum = CDbl(sNumber)
  41. dFixedNum = Fix(dNum)
  42. sStrNum = CStr(dFixedNum)
  43. If NrOver3 > 0 Then
  44.     For nCounter = (3 - NrOver3) To 1 Step -1
  45.         sStrNum = "0" & sStrNum
  46.     Next nCounter
  47. End If
  48. 'reset length after adding leading zero's
  49. nLength = Len(sStrNum)
  50. 'break number into groups of three and send to
  51. 'converting routine
  52. For nCounter = nLength To 1 Step -3
  53.     nDecPlace = nDecPlace + 1
  54.     sChar = ""
  55.         For nCounter2 = nCounter - 2 To nCounter Step 1
  56.         sChar = sChar & Mid(sStrNum, nCounter2, 1)
  57.     Next nCounter2
  58.     'add converted number to the collection
  59.     WrdCol.Add NumberToWord(sChar, nDecPlace)
  60. Next nCounter
  61. 'covert the cents into words
  62. Dim X
  63. Dim Centss
  64.     For X = WrdCol.Count To 1 Step -1
  65.         fChange = fChange & " " & WrdCol(X)
  66.     Next X
  67.     X = (NumberToWord(CStr(Remainder), 1))
  68.  
  69. If Remainder > 0 Then
  70.  
  71.     
  72.     If Remainder = 1 Then
  73.         Centss = " and " & X & "Cent only."
  74.     Else
  75.         Centss = " and " & X & "Cents only."
  76.     End If
  77.     
  78. Else
  79.     Centss = " only."
  80. End If
  81. If fChange = " " Then fChange = "Zero "
  82.  
  83. If IsMissing(bUseForChecks) Then bUseForChecks = False
  84. If sCurrency = "" Then sCurrency = "Dollar"
  85. If bUseForChecks = True Then
  86.     If fChange = " One " Then
  87.         fChange = fChange & sCurrency & Centss
  88.     Else
  89.         fChange = fChange & sCurrency & "s" & Centss
  90.     End If
  91. Else
  92.     If Remainder > 0 Then
  93.         fChange = fChange & "and " & X & "Hundredths."
  94.     End If
  95.     
  96.     
  97. End If
  98.     
  99.  
  100. Exit_Function:
  101.     Exit Function
  102. DoError:
  103.     Select Case Err.Number
  104.         Case 13
  105.             
  106.             sErrString = "Unable to evaluate Number"
  107.        
  108.             MsgBox sErrString, vbCritical + vbExclamation, "Sorry."
  109.         Case Else
  110.             
  111.             sErrString = Err.Description & "  Error Number is: " & Err.Number
  112.             MsgBox sErrString, vbCritical + vbExclamation, "Unknown Error"
  113.             
  114.      End Select
  115.     
  116.           
  117.         
  118. End Function
  119. Private Function NumberToWord$(ByVal sStrNum$, ByVal TimesThrough%)
  120. Dim NumArray: Dim TeenArray: Dim TenArray: Dim UnitArray
  121. Dim nCounter%: Dim nLength%: Dim nChar%: Dim nDecPlace%
  122. Dim NrOver3
  123. Dim DoDigit As Boolean
  124.  
  125. NumArray = Array("One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine")
  126. TeenArray = Array("Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
  127. TenArray = Array("", "Twenty ", "Thirty ", "Forty ", "Fifty ", "Sixty ", "Seventy ", "Eighty ", "Ninety ")
  128. UnitArray = Array("", "Thousand", "Million", "Billion", "Trillion")
  129.  
  130. nLength = Len(sStrNum)
  131. NrOver3 = nLength Mod 3
  132. If NrOver3 > 0 Then
  133.     For nCounter = (3 - NrOver3) To 1 Step -1
  134.         sStrNum = "0" & sStrNum
  135.     Next nCounter
  136. End If
  137. nLength = Len(sStrNum)
  138.  
  139. nDecPlace = 4
  140. DoDigit = True
  141. For nCounter = 1 To nLength
  142.     nDecPlace = nDecPlace - 1
  143.     nChar = Mid(sStrNum, nCounter, 1)
  144.     If nChar > 0 Then
  145.     Select Case nDecPlace
  146.         Case 3
  147.         If Val(Mid(sStrNum, 2, 1)) > 1 Then
  148.             NumberToWord = NumArray(nChar - 1) & " Hundred and "
  149.         Else
  150.             NumberToWord = NumArray(nChar - 1) & " Hundred "
  151.         End If
  152.         Case 2
  153.            
  154.             If nChar = 1 Then
  155.                 NumberToWord = NumberToWord & TeenArray(Mid(sStrNum, nCounter + 1, 1)) & " " & UnitArray(TimesThrough - 1)
  156.                 DoDigit = False
  157.             Else
  158.                 
  159.                 NumberToWord = NumberToWord & TenArray(nChar - 1)
  160.             End If
  161.         Case 1
  162.             If DoDigit = True Then
  163.                 NumberToWord = NumberToWord & NumArray(nChar - 1) & " " & UnitArray(TimesThrough - 1)
  164.             End If
  165.     End Select
  166.     End If
  167. Next nCounter
  168. End Function
  169.  
  170.